
unit SynHighlighterODScript;

{$I SynEdit.inc}

interface

uses
  SysUtils, Classes,
  {$IFDEF SYN_CLX}
  Qt, QControls, QGraphics,
  {$ELSE}
  Windows, Messages, Controls, Graphics, Registry,
  {$ENDIF}
  SynEditTypes, SynEditHighlighter, SynHighlighterHashEntries;

type
  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkNumber,
    tkSpace, tkString, tkVariable);

  TRangeState = (rsUnknown, rsCStyleComment);

  TProcTableProc = procedure of object;

  TSynODScriptSyn = class(TSynCustomHighlighter)
  private
    fLine: PChar;
    fLineNumber: integer;
    fProcTable: array[#0..#255] of TProcTableProc;

    Run: longint;
    fStringLen: integer;
    fToIdent: PChar;
    fTokenPos: integer;
    fTokenID: TtkTokenKind;
    fRange: TRangeState;
    fCommentAttri: TSynHighlighterAttributes;
    fVariableAttri: TSynHighlighterAttributes;
    fIdentifierAttri: TSynHighlighterAttributes;
    fKeyAttri: TSynHighlighterAttributes;
    fNumberAttri: TSynHighlighterAttributes;
    fSpaceAttri: TSynHighlighterAttributes;
    fStringAttri: TSynHighlighterAttributes;


    fKeywords: TSynHashEntryList;

    function KeyHash(ToHash: PChar): integer;
    function KeyComp(const aKey: string): boolean;
    procedure NullProc;
    procedure SpaceProc;
    procedure IdentProc;
    procedure NumberProc;

    procedure CommentOpenProc;
    procedure CStyleCommentOpenProc;
    procedure CStyleCommentProc;

    procedure StringOpenProc;
    procedure UnknownProc;
    procedure VariableProc;


    procedure DoAddKeyword(AKeyword: string; AKind: integer);
    procedure MakeMethodTables;


  protected
    function GetIdentChars: TSynIdentChars; override;
  public
    {$IFNDEF SYN_CPPB_1}
    class {$ENDIF}
    function GetLanguageName: string; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function IdentKind(MayBe: PChar): TtkTokenKind;
    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;
      override;
    function GetRange: Pointer; override;
    procedure ResetRange; override;
    procedure SetRange(Value: Pointer); override;
    function GetEol: boolean; override;
    function GetToken: string; override;
    function GetTokenAttribute: TSynHighlighterAttributes; override;
    function GetTokenID: TtkTokenKind;
    function GetTokenKind: integer; override;
    function GetTokenPos: integer; override;
    procedure Next; override;
    procedure SetLine(NewValue: string; LineNumber: integer); override;

  published
    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri write fSpaceAttri;
    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri write fIdentifierAttri;
    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;
    property NumberAttri: TSynHighlighterAttributes read fNumberAttri write fNumberAttri;
    property StringAttri: TSynHighlighterAttributes read fStringAttri write fStringAttri;
    property CommentAttri: TSynHighlighterAttributes read fCommentAttri write fCommentAttri;
    property VariableAttri: TSynHighlighterAttributes read fVariableAttri write fVariableAttri;
  end;

procedure Register;


var
  TokensFileName: String;


implementation

uses
  SynEditStrConst,
  IniFiles;


resourcestring
  SYNS_FilterOD = 'OD Script Files (*.osc)|*.osc';
  SYNS_AttrParameter = 'Parameter';
  SYNS_LangNSIS = 'OD Script';

procedure Register;
begin
  RegisterComponents(SYNS_HighlightersPage, [TSynODScriptSyn]);
end;

const
  UserVarValidChars = ['a'..'z', 'A'..'Z', '_'];

var
  Identifiers: array[#0..#255] of bytebool;
  mHashTable: array[#0..#255] of integer;

const
  Keywords: string =
    'ADD,AI,ALLOC,AN,AND,AO,ASK,ASM,ASMTXT,ATOI,' +
    'BACKUP,BC,BD,BEGINSEARCH,BP,BPCND,BPD,BPHWC,BPHWS,BPL,BPLCND,' +
    'BPGOTO,BPMC,BPRM,BPWM,BPX,BUF,BPHWCALL,' +
    'CLOSE,CMP,CMT,COB,COE,' +
    'DBH,DBS,DEC,DIV,DM,DMA,DPE,' +
    'EOB,EOE,ERUN,ESTI,ESTO,EVAL,EXEC,ENDE,ENDSEARCH,' +
    'FILL,FIND,FINDCALLS,FINDCMD,FINDCMDS,FINDOP,FINDMEM,FREE,' +
    'GAPI,GBPM,GBPR,GCI,GCMT,GMA,GMEMI,GMEXP,GMI,GN,GO,GOPI,GPA,GPI,GREF,GRO,' +
    'GSL,GSTR,GSTRU,' + 
    'HANDLE,HISTORY,' +
    'INC,ITOA,' +
    'JA,JAE,JB,JBE,JE,JMP,JNE,' +
    'KEY,' +
    'LBL,LC,LCLR,LEN,LM,LOG,LOGBUF,LOADLIB,' +
    'MOV,MEMCPY,MSG,MSGYN,MUL,' +
    'NAMES,NEG,NOT,' +
    'OR,OPCODE,OPENDUMP,OPENTRACE,OLLY,' +
    'PAUSE,POP,POPA,PREOP,PUSH,PUSHA,' +
    'RBP,READSTR,REF,REPL,RET,REV,ROL,ROR,RTR,RTU,RUN,' +
    'SCMP,SCMPI,SETOPTION,SHL,SHR,STI,STO,STR,SUB,' +
    'TC,TEST,TI,TICK,TICND,TO,TOCND,' +
    'UNICODE,' +
    'VAR,' +
    'WRT,WRTA,' +
    'XOR,XCHG';


  Variables: String = '$RESULT,$VERSION';


procedure MakeIdentTable;
var
  c: char;
begin
  FillChar(Identifiers, SizeOf(Identifiers), 0);
  for c := 'a' to 'z' do
    Identifiers[c] := True;
  for c := 'A' to 'Z' do
    Identifiers[c] := True;
  for c := '0' to '9' do
    Identifiers[c] := True;

  Identifiers['_'] := True;


  FillChar(mHashTable, SizeOf(mHashTable), 0);
  mHashTable['_'] := 1;
  mHashTable['.'] := 1;
  mHashTable['!'] := 1;
  for c := 'a' to 'z' do
    mHashTable[c] := 2 + Ord(c) - Ord('a');
  for c := 'A' to 'Z' do
    mHashTable[c] := 2 + Ord(c) - Ord('A');
end;

function TSynODScriptSyn.KeyHash(ToHash: PChar): integer;
begin
  Result := 0;
  while Identifiers[ToHash^] do
  begin
    Result := 7 * Result + mHashTable[ToHash^];

    inc(ToHash);
  end;
  Result := Result and $1FF;
  fStringLen := ToHash - fToIdent;
end;

function TSynODScriptSyn.KeyComp(const aKey: string): boolean;
var
  i: integer;
  pKey1, pKey2: PChar;
begin
  pKey1 := fToIdent;
  pKey2 := pointer(aKey);
  for i := 1 to fStringLen do
  begin
    if mHashTable[pKey1^] <> mHashTable[pKey2^] then
    begin
      Result := False;
      exit;
    end;
    Inc(pKey1);
    Inc(pKey2);
  end;
  Result := True;
end;

function TSynODScriptSyn.IdentKind(MayBe: PChar): TtkTokenKind;
var
  Entry: TSynHashEntry;
begin
  fToIdent := MayBe;
  Entry := fKeywords[KeyHash(MayBe)];
  while Assigned(Entry) do
  begin
    if Entry.KeywordLen > fStringLen then
      break
    else if Entry.KeywordLen = fStringLen then
      if KeyComp(Entry.Keyword) then
      begin
        Result := TtkTokenKind(Entry.Kind);
        exit;
      end;
    Entry := Entry.Next;
  end;
  Result := tkIdentifier;
end;

procedure TSynODScriptSyn.MakeMethodTables;
var
  I: char;
begin
  for I := #0 to #255 do
    case I of
      #0:             fProcTable[I] := NullProc;
      #1..#32:        fProcTable[I] := SpaceProc;
      '0'..'9', '#':  fProcTable[I] := NumberProc;
      'A'..'Z', 'a'..'z','_':
                      fProcTable[I] := IdentProc;
      '/':            fProcTable[I] := CStyleCommentOpenProc;
      ';':            fProcTable[I] := CommentOpenProc;
      '"':            fProcTable[I] := StringOpenProc;
      '$':            fProcTable[I] := VariableProc;
      else
        fProcTable[I] := UnknownProc;
    end;
end;

constructor TSynODScriptSyn.Create(AOwner: TComponent);
  function LoadTokensFromFile(const Section, Default: String): String;
  var
    Lst: TStringList;
    C: Integer;
  begin
    Result := '';
    with TIniFile.Create(TokensFileName) do
    try
      Lst := TStringList.Create;
      try
        ReadSection(Section, Lst);
        for C := 0 to Lst.Count - 1 do
          Result := Result + ReadString(Section, Lst[C], '') + ',';
      finally
        Lst.Free;
      end;
    finally
      Free;
    end;
    if Result = '' then
      Result := Default;
  end;

begin
  inherited Create(AOwner);
  fKeywords := TSynHashEntryList.Create;

  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment);
  fCommentAttri.Foreground := clGreen;
  AddAttribute(fCommentAttri);

  fVariableAttri := TSynHighlighterAttributes.Create(SYNS_AttrVariable);
  fVariableAttri.Foreground := clPurple;
  AddAttribute(fVariableAttri);

  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier);
  fIdentifierAttri.Foreground := clWindowText;
  AddAttribute(fIdentifierAttri);

  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord);
  fKeyAttri.Foreground := clBlue;
  AddAttribute(fKeyAttri);

  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber);
  fNumberAttri.Foreground := clRed;
  AddAttribute(fNumberAttri);

  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace);
  AddAttribute(fSpaceAttri);

  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString);
  fStringAttri.Foreground := clFuchsia;
  AddAttribute(fStringAttri);

  SetAttributesOnChange(DefHighlightChange);


  EnumerateKeywords(Ord(tkKey), LoadTokensFromFile(SYNS_AttrReservedWord, KeyWords),
     IdentChars, DoAddKeyword);

  EnumerateKeywords(Ord(tkVariable), LoadTokensFromFile(SYNS_AttrVariable, Variables),
    IdentChars, DoAddKeyWord);


  MakeMethodTables;
  fDefaultFilter := SYNS_FilterOD;

end;

destructor TSynODScriptSyn.Destroy;
begin
  fKeywords.Free;
  inherited Destroy;
end;

procedure TSynODScriptSyn.SetLine(NewValue: string; LineNumber: integer);
begin
  fLine := PChar(NewValue);
  Run := 0;
  fLineNumber := LineNumber;
  Next;
end;

procedure TSynODScriptSyn.IdentProc;
var
  P: PChar;
  I: Integer;
begin
  // Added by HMRS 05/14/2003 BEGIN
  { This check for vars inside strings without quotes. This is necessary since
   the '$' character is an identifier char. }
  P := fLine + Run;
  I := 0;
  while Identifiers[P^] do
  begin
    if P^ = '$' then
    begin
      fTokenID := tkIdentifier;
      Inc(Run, I);
      Exit;
    end;
    Inc(I);
    Inc(P);
  end;
  // HMRS 05/14/2003 END

  // Modified by HMRS 22/04/2003 BEGIN
  fTokenID := IdentKind(fLine + Run);
  case fTokenID of
    tkKey:
      begin
        P := FLine;
        while P < FLine + Run do
        begin
          if not (P^ in [' ', #9]) then
          begin
            fTokenID := tkIdentifier;
            Break;
          end;
          Inc(P);
        end;
      end;
      // HMRS END
  end;
  // HMRS 22/04/2003 END

  // HMRS 05/12/2003 END
  Inc(Run, fStringLen);
end;

procedure TSynODScriptSyn.UnknownProc;
begin
  inc(Run);
  fTokenID := tkIdentifier;
end;

procedure TSynODScriptSyn.NullProc;
begin
  fTokenID := tkNull;
end;

procedure TSynODScriptSyn.SpaceProc;
begin
  fTokenID := tkSpace;
  repeat
    Inc(Run);
  until (fLine[Run] > #32) or (fLine[Run] = #0);
end;

procedure TSynODScriptSyn.CommentOpenProc;
begin
  fTokenID := tkComment;
  repeat
    Inc(Run);
  until fLine[Run] in [#0, #10, #13];

end;

procedure TSynODScriptSyn.CStyleCommentOpenProc;
begin

  Inc(Run);
  if fLine[Run] = '/' then
  begin
    fTokenID := tkComment;
    fRange := rsUnknown;
    repeat
      Inc(Run);
    until fLine[Run] in [#0, #10, #13];

  end else if fLine[Run] = '*' then
  begin
    fTokenID := tkComment;
    fRange := rsCStyleComment;
    Inc(Run);
    if fLine[Run] in [#0, #10, #13] then exit;
    
    repeat
      if (fLine[Run] = '*') and (fLine[Run + 1] = '/') then
      begin
        fTokenID := tkComment;
        fRange := rsUnknown;
        break;
      end;
      Inc(Run);
    until fLine[Run] in [#0, #10, #13];
  end
  else
    fTokenID := tkIdentifier;
end;

procedure TSynODScriptSyn.CStyleCommentProc;
begin
  case fLine[Run] of
    #0: NullProc;
    #1..#32: SpaceProc;
    else
    begin
      fTokenID := tkComment;
      repeat
        if (fLine[Run] = '*') and (fLine[Run + 1] = '/') then
        begin
          fRange := rsUnknown;
          Inc(Run, 2);
          Break;
        end;
        Inc(Run);
      until fLine[Run] in [#0, #10, #13];
    end;
  end;
end;
// Added by HMRS 06/04/2003 END

procedure TSynODScriptSyn.NumberProc;
var
  charset: set of char;
begin
  fTokenID := tkNumber;

  if (fLine[Run] = '#') then
  begin
    //Inc(Run);
    charset := ['0'..'9', 'A'..'F', 'a'..'f', '#', '?'];//hex
  end
  else
    charset := ['0'..'9','A'..'F', 'a'..'f'];//dec or octal

  repeat
    Inc(Run);
  until not (fLine[Run] in charset);

  if not (fLine[Run] in [' ', #0, #13, #10]) then
    fTokenID := tkIdentifier;
end;

procedure TSynODScriptSyn.StringOpenProc;
begin
  fTokenID := tkString;
  repeat
    Inc(Run);
    if fLine[Run] = '"' then
    begin
      Break;
    end;
  until (fLine[Run] in [#0, #10, #13]);

end;


procedure TSynODScriptSyn.VariableProc;
begin
  fTokenID := tkVariable;
  repeat
    inc(Run);
  until (fLine[Run] in [#0, #10, #13, ' ', ',']);

end;

procedure TSynODScriptSyn.Next;
begin
  fTokenPos := Run;
  case fRange of
    rsCStyleComment: CStyleCommentProc;
    else
    begin
      fRange := rsUnknown;
      fProcTable[fLine[Run]];
    end;
  end;
end;

function TSynODScriptSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;
begin
  case Index of
    SYN_ATTR_COMMENT: Result := fCommentAttri;
    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;
    SYN_ATTR_KEYWORD: Result := fKeyAttri;
    SYN_ATTR_STRING: Result := fStringAttri;
    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;
    else
      Result := nil;
  end;
end;

function TSynODScriptSyn.GetEol: boolean;
begin
  Result := (fTokenId = tkNull);
end;

function TSynODScriptSyn.GetToken: string;
var
  Len: longint;
begin
  Len := Run - fTokenPos;
  SetString(Result, (FLine + fTokenPos), Len);
end;

function TSynODScriptSyn.GetTokenAttribute: TSynHighlighterAttributes;
begin
  case fTokenID of
    tkComment:    Result := fCommentAttri;
    tkVariable:   Result := fVariableAttri;
    tkIdentifier: Result := fIdentifierAttri;
    tkKey:        Result := fKeyAttri;
    tkNumber:     Result := fNumberAttri;
    tkSpace:      Result := fSpaceAttri;
    tkString:     Result := fStringAttri;
    else
      Result := nil;
  end;
end;

function TSynODScriptSyn.GetTokenKind: integer;
begin
  Result := Ord(fTokenId);
end;

function TSynODScriptSyn.GetTokenID: TtkTokenKind;
begin
  Result := fTokenId;
end;

function TSynODScriptSyn.GetTokenPos: integer;
begin
  Result := fTokenPos;
end;

function TSynODScriptSyn.GetIdentChars: TSynIdentChars;
begin
  Result :=  TSynValidStringChars +
    ['#', '$']; { <- for my Script editor help system }

end;

{$IFNDEF SYN_CPPB_1} class {$ENDIF}
function TSynODScriptSyn.GetLanguageName: string;
begin
  Result := SYNS_LangNSIS;
end;

procedure TSynODScriptSyn.DoAddKeyword(AKeyword: string; AKind: integer);
var
  HashValue: integer;
begin
  HashValue := KeyHash(PChar(AKeyword));
  fKeywords[HashValue] := TSynHashEntry.Create(AKeyword, AKind);
end;



procedure TSynODScriptSyn.ResetRange;
begin
  fRange := rsUnknown;
end;

procedure TSynODScriptSyn.SetRange(Value: Pointer);
begin
  fRange := TRangeState(Value);
end;

function TSynODScriptSyn.GetRange: Pointer;
begin
  Result := Pointer(fRange);
end;

initialization
  MakeIdentTable;
  {$IFNDEF SYN_CPPB_1}
  RegisterPlaceableHighlighter(TSynODScriptSyn);
  {$ENDIF}

  TokensFileName := ExtractFilePath(ParamStr(0)) + 'ODScript.syn';

end.

